home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
MCQUAY1
/
MENUTOOL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-05-22
|
9KB
|
342 lines
{*************************************************
Menu Tools for Turbo Vision
A Set of functions to modify TV Menus
Copyright 1995 McQuay Technologies
Released into the public domain
**************************************************}
unit MenuTool;
interface
uses Objects, Menus;
function MS_MaxLabel(P:Pmenu):word;
function MS_BarSize(P:Pmenu):word;
function MS_count(P:Pmenu):word;
function MS_Type(P:PMenuItem):word;
function MS_Member(P:Pmenu;Item:PmenuItem):boolean;
function MS_Prev(P:Pmenu;Item:PmenuItem):PmenuItem;
procedure MS_SwapItems(P:Pmenu;P1,P2:PmenuItem);
procedure MS_DisposeMenuItem(P:PmenuItem);
procedure MS_Insert(P:Pmenu;AtItem,NewItem:PmenuItem);
procedure MS_Delete(P:Pmenu;Item:PmenuItem);
function MS_DupNewItem(Item:PmenuItem):PmenuItem;
procedure MS_DisableItem(Item:PMenuItem);
procedure MS_EnableItem (Item:PMenuItem);
procedure MS_DisableCommand(P:Pmenu;Command:word);
procedure MS_EnableCommand (P:Pmenu;Command:word);
function MS_FindCommand(P:Pmenu;Command:word):PmenuItem;
procedure MS_RenameItem(Item:PMenuItem; name:TMenuStr);
implementation
const
LineItem = 1;
SubMenuItem = 2;
CommandItem = 0;
{------------------------------------------------------------------}
function MS_MaxLabel(P:Pmenu):word;
var
Temp:PmenuItem;
i:word;
begin
I := 0;
if P<>nil then
begin
Temp := P^.items;
while Temp<>nil do
begin
if Temp^.name <> nil then
if length(Temp^.name^)>i then
i:=Length(Temp^.name^);
Temp := Temp^.next;
end;
end;
MS_MaxLabel := i;
end;
{------------------------------------------------------------------}
function MS_BarSize(P:Pmenu):word;
var
Temp:PmenuItem;
i:word;
begin
I := 0;
if P<>nil then
begin
Temp := P^.items;
while Temp<>nil do
begin
if Temp^.name <> nil then
i:=I+Length(Temp^.name^) +2;
Temp := Temp^.next;
end;
end;
MS_BarSize := i;
end;
{------------------------------------------------------------------}
function MS_count(P:Pmenu):word;
var
Temp:PmenuItem;
i:word;
begin
if P<>nil then
begin
I := 0;
Temp := P^.items;
while Temp<>nil do
begin
Inc(i);
Temp := Temp^.next;
end;
MS_Count := i;
end
else
MS_Count := 0;
end;
{------------------------------------------------------------------}
function MS_Type(P:PMenuItem):word;
begin
if P<>nil then
begin
with P^ do
If Name=nil Then MS_Type:=1 else
if Command=0 then MS_Type:=2 else
MS_Type := 0;
end
else
MS_Type := $ffff;
end;
{------------------------------------------------------------------}
function MS_Member(P:Pmenu;Item:PmenuItem):boolean;
var
TemP:PmenuItem;
begin
if P<>nil then
begin
Temp := P^.items;
while (Temp<>nil) and (Temp<>Item) do
Temp := Temp^.next;
if Temp<>nil then
MS_member := true
else
MS_Member := false;
end
else
MS_member := false;
end;
{------------------------------------------------------------------}
function MS_Prev(P:Pmenu;Item:PmenuItem):PmenuItem;
var
TemP,Prev:PmenuItem;
begin
if P<>nil then
begin
Temp := P^.items;
Prev := nil;
while (Temp<>nil) and (Temp<>Item) do
begin
prev := Temp;
Temp := Temp^.next;
end;
if Temp<>nil then
MS_Prev := prev
else
MS_Prev := nil;
end;
end;
{------------------------------------------------------------------}
procedure MS_SwapItems(P:Pmenu;P1,P2:PmenuItem);
var
Prev1,Prev2,temp:PmenuItem;
begin
if (P<>nil) and (MS_member(P,P1))and(MS_Member(P,P2)) then
begin
{ Get Previous }
Prev1 := MS_Prev(P,P1);
Prev2 := MS_Prev(P,P2);
{ Save P2's next becuase we set it first }
Temp := P2^.next;
{ If Prev = nil then it is top of list }
if Prev1 = nil then
P^.items := p2
else
{ if the prev is not the other then set next }
If Prev1<>P2 then
Prev1^.next := P2;
{ If Prev = nil then it is top of list }
if Prev2 = nil then
P^.items := p1
else
{ if the prev is not the other then set next }
If Prev2<>P1 then
Prev2^.next := P1;
{ If P1 not above P2 then swap else P2 > P1 }
if P1^.next<>p2 then
p2^.next := P1^.next
else
p2^.next := p1;
{ If P2 not above P1 then swap else P1 > P2 }
if Temp<>p1 then
p1^.next := temp
else
p1^.next := p2;
end;
end;
{----------------------------------------------------------------}
procedure MS_DisposeMenuItem(P:PmenuItem);
begin
If P<>nil then
begin
if P^.name <> nil then
begin
disposeStr(P^.name);
if(P^.command <>0) then
begin
if (P^.param <> nil) then
disposeStr(P^.param);
end
else
if P^.submenu <> nil then disposeMenu(P^.submenu);
end;
dispose(P);
end;
end;
{----------------------------------------------------------------}
procedure MS_Insert(P:Pmenu;AtItem,NewItem:PmenuItem);
var
Prev:PmenuItem;
begin
if (P<>nil)and(NewItem<>nil) then
if P^.items = nil
then P^.items := NewItem
else
if AtItem = Nil then
begin
NewItem^.next := P^.items;
P^.items := NewItem;
end
else
if MS_member(P,AtItem) then
begin
Prev := MS_prev(P,AtItem);
if Prev=nil then
P^.items := NewItem
else
Prev^.next := NewItem;
NewItem^.next := AtItem;
end;
end;
{----------------------------------------------------------------}
procedure MS_Delete(P:Pmenu;Item:PmenuItem);
var
Prev:PmenuItem;
begin
if (P<>nil)and(Item<>nil) then
if MS_member(P,Item) then
begin
Prev := MS_prev(P,Item);
if Prev=nil then
P^.items := Item^.next
else
Prev^.next := Item^.next;
end;
end;
{----------------------------------------------------------------}
function MS_DupNewItem(Item:PmenuItem):PmenuItem;
var
NewMenuItem:PmenuItem;
S:TmenuStr;
Dummy:Pmenu;
begin
with Item^ do
begin
case MS_Type(Item) of
LineItem:NewMenuItem := NewLine(nil);
CommandItem:
begin
if param = nil then
S:=''
else
S:=param^;
NewMenuItem := newItem(name^,S,KeyCode,Command,HelpCtx,nil);
end;
SubMenuItem : begin
dummy := Newmenu(nil);
NewMenuItem := NewSubmenu(name^,HelpCtx,dummy,nil);
NewMenuItem^.command := 0;
end;
end;
if NewMenuItem<>nil then
NewMenuItem^.disabled := disabled;
end;
MS_DupNewItem := NewMenuItem;
end;
{----------------------------------------------------------------}
function MS_FindCommand(P:Pmenu;Command:word):PmenuItem;
var
Temp,Stemp:PmenuItem;
found:boolean;
begin
Temp := nil;
found := false;
if P<>nil then
begin
Temp := P^.items;
while (Temp<>nil)and (not found) do
begin
case MS_type(temp) of
submenuitem:
begin
Stemp := MS_FindCommand(Temp^.submenu,command);
if Stemp<>nil then
begin
found := true;
Temp := Stemp;
end
end;
CommandItem:
if Temp^.command = command then found := true;
end;
if not found then
Temp := Temp^.next;
end;
end;
MS_FindCommand := Temp;
end;
{----------------------------------------------------------------}
procedure MS_DisableItem(Item:PMenuItem);
begin
if Item<>nil then
Item^.disabled := true;
end;
{----------------------------------------------------------------}
procedure MS_EnableItem (Item:PMenuItem);
begin
if Item<>nil then
Item^.disabled := false;
end;
{----------------------------------------------------------------}
procedure MS_DisableCommand(P:Pmenu;Command:word);
var
Temp:PmenuItem;
begin
Temp := MS_FindCommand(P,Command);
MS_DisableItem(Temp);
end;
{----------------------------------------------------------------}
procedure MS_EnableCommand (P:Pmenu;Command:word);
var
Temp:PmenuItem;
begin
Temp := MS_FindCommand(P,Command);
MS_EnableItem(Temp);
end;
{----------------------------------------------------------------}
procedure MS_RenameItem(Item:PMenuItem; name:TMenuStr);
begin
if Item<>nil then
begin
disposestr(Item^.name);
Item^.name := newstr(name);
end;
end;
end.
